The X-Philes (2nd Revision)

home *** CD-ROM | disk | FTP | other *** search

/ The X-Philes (2nd Revision) / The X-Philes Number 1 (1995).iso / xphiles / hp48hor1 / symbmat2.src < prev next >

Wrap

Text File | 1991-10-19 | 5KB | 315 lines

%%HP: T(3)A(R)F(.); @ SYMBMAT2 by Marc E Blair DIR \->q \<< IF QR THEN '\->q\[]' DUP RCL SWAP PURGE '\->q' STO ELSE '\->q' DUP RCL SWAP PURGE '\->q\[]' STO END QR NOT 'QR' STO \>> Rr \<< Dec \-> L S \<< S L \161RR 0 1 S FOR A A L * A - 2 + PICK + NEXT IF ZRO? SWAP DROP NOT THEN S L \161RR END 1 L FOR A S \->LIST L A - S * A + ROLLD NEXT L \->LIST \>> \>> det \<< Dec DROP MNN \>> EC \<< EVAL DO DUP EXPAN DUP ROT UNTIL SIZE SWAP SIZE == END DO DUP COLCT DUP ROT UNTIL SIZE SWAP SIZE == END \>> SIMEQ \<< DUP Dec DUP IF 6 < THEN DUP2 1 - IF == THEN DROP \-> Ss \<< 0 Ss FOR Aa Ss DUP * Ss FOR Bb Bb Aa + PICK Ss NEG STEP Ss \->LIST Ss Ss 1 + * 1 + ROLLD NEXT Ss Ss 1 + * DROPN Ss 1 + ROLL \-> Cc \<< Ss DUPN Ss \->LIST det \-> Dd \<< IF Dd ZRO? SWAP DROP NOT THEN 1 Ss FOR Aa Ss DUPN Aa ROLL DROP Cc Aa ROLLD Ss \->LIST det Dd / IF QR THEN \->Q END Ss 1 + ROLLD NEXT Ss DROPN Ss \->LIST ELSE Ss DROPN "No Solution" END \>> \>> \>> ELSE * DROPN "BAD # OF EQS" END SWAP DROP ELSE * DROPN SM2 END \>> inv \<< Dec \-> S L \<< 0 L 1 - FOR A 0 S 1 - FOR B A B == L S * L - 1 + A L * - ROLLD NEXT NEXT L S \>> DUP + \-> L S \<< S L \161RR 1 L FOR A S 2 / \->LIST L A - S * A + S 2 / + ROLLD S 2 / DROPN NEXT L \->LIST \>> \>> MEC \<< OBJ\-> \-> A \<< 1 A 1 - FOR B + NEXT OBJ\-> \-> S \<< 1 S FOR C EC S ROLLD NEXT 1 A FOR D S A / \->LIST S S A / D * - D + ROLLD NEXT A \->LIST \>> \>> \>> SM2 \<< Rr 0 'ER' STO { } SWAP OBJ\-> \-> S \<< 1 S FOR A OBJ\-> \-> L \<< L S A - - ROLL IF 1 \=/ THEN 1 'ER' STO END S A - L + ROLL + S A - L 1 - + ROLLD 0 1 L 2 - FOR C + NEXT IF 0 \=/ THEN 1 'ER' STO END \>> NEXT IF ER 1 == THEN DROP "NO SOLUTION" END 'ER' PURGE \>> \>> Dec \<< OBJ\-> DUP TYPE IF 5 == THEN EVAL ELSE \-> L \<< 1 L 1 - FOR A + NEXT OBJ\-> L / L SWAP \>> END \>> ZRO? \<< DUP TYPE 0 IF \=/ THEN 0 ELSE DUP IF 0 \=/ THEN 0 ELSE 1 END END \>> \161RR \<< \-> L S \<< 0 S 1 - FOR A S L * A - DUP 1 + PICK \-> F M1 \<< 1 S 1 - FOR B F B L * - DUP 1 + PICK \-> C M2 \<< M2 ZRO? IF NOT THEN DROP 0 L 1 - FOR D C A + D - ROLL M1 0 'DOIT' STO ZRO? IF NOT THEN * ELSE DROP 1 'DOIT' STO END F A + D - PICK M2 ZRO? IF NOT THEN * ELSE DROP 1 'DOIT' STO END - EXPAN COLCT C A + D - ROLLD NEXT ELSE DROP END \>> NEXT 1 L FOR Q S L * ROLL NEXT \>> 'DOIT' PURGE NEXT 0 S 1 - FOR B L S B - * B - PICK S B - L * \-> D F \<< 0 L 1 - FOR C F C - ROLL IF D TYPE 0 == THEN IF D 0 == THEN \oo * ELSE D / COLCT IF QR THEN \->Q END DUP TYPE 9 == OVER EVAL DUP IP == AND IF DUP TYPE 0 == THEN IF THEN EVAL END ELSE DROP END END ELSE D / COLCT END F C - ROLLD NEXT \>> NEXT \>> \>> MNN \<< \-> Ss \<< IF Ss 3 == THEN 6 DUPN 6 DUPN ROT DROP 4 ROLL * 3 ROLLD * - SWAP DROP 16 PICK * 16 ROLLD SWAP DROP 4 ROLL DROP 4 ROLL * 3 ROLLD * - 9 PICK * 10 ROLLD DROP ROT DROP 4 ROLL * 3 ROLLD * - * ROT DROP SWAP DROP SWAP - + ELSE IF Ss 2 == THEN 4 ROLL * 3 ROLLD * - ELSE 1 Ss FOR Aa Ss DUP DUP * SWAP - DUPN Ss DUP * Ss 2 * - 0 FOR Bb Bb Aa + ROLL DROP Ss NEG STEP Ss 1 - MNN Ss DUP * Ss - Aa + 1 + PICK * -1 Aa Ss + ^ * Ss Ss * 1 + ROLLD NEXT Ss Ss * DROPN 1 Ss 1 - FOR Aa + NEXT END END \>> \>> QR 0 END